home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / faces.tcl.z / faces.tcl
Text File  |  2002-07-08  |  14KB  |  573 lines
  1. # 
  2. # faces.tcl
  3. #
  4. # facesaver support (bitmap display of who sent a message).
  5. #
  6. # Copyright (c) 1993 Xerox Corporation.
  7. # Use and copying of this software and preparation of derivative works based
  8. # upon this software are permitted. Any distribution of this software or
  9. # derivative works must comply with all applicable United States export
  10. # control laws. This software is made available AS IS, and Xerox Corporation
  11. # makes no warranty about the software, its performance or its conformity to
  12. # any specification.
  13.  
  14. #### Faces support
  15.  
  16. set faces(debug) 0
  17. proc Dputs args { global faces; if $faces(debug) {puts $args} }
  18. set faces(timing) 0
  19. proc Tputs args { global faces; if $faces(timing) {puts $args} }
  20.  
  21. # Compute faces search path
  22. proc Face_SetPath {} {
  23.     global faces env faceCache
  24.  
  25.     catch {unset faceCache}
  26.  
  27.     if ![info exists faces(sets)] {
  28.     if [info exists faces(set)] {
  29.         # backwards compatibility with old "exmh" script
  30.         set faces(set,user) $faces(set)
  31.         set faces(set,unknown) $faces(set)
  32.         set faces(set,news) $faces(set)
  33.     }
  34.     set faces(sets) {user unknown}
  35.     }
  36.  
  37.     # tail component for each set
  38.     set faces(name,user) {$user}
  39.     set faces(name,unknown) unknown
  40.     set faces(name,news) unknown
  41.  
  42.     set faces(defaultDomain) [string tolower \
  43.     [string trim $faces(defaultDomain) ". "]]
  44.     # Build search path
  45.     foreach set $faces(sets) {
  46.     set faces(path,$set) {}
  47.     }
  48.     set faces(path,news) {}
  49.     if [info exists env(FACEPATH)] {
  50.     set faces(base) ""
  51.     foreach dir [split $env(FACEPATH) :] {
  52.         foreach set $faces(sets) {
  53.         if ![file isdirectory $dir] continue
  54.         if {[lsearch -exact $faces(set,$set) [file tail $dir]] >= 0} {
  55.             FaceAddPath $set $dir
  56.         } else {
  57.             FaceAddPath user $dir
  58.             FaceAddPath unknown $dir
  59.             FaceAddPath news $dir
  60.         }
  61.         }
  62.     }
  63.     } else {
  64.     set faces(base) $faces(dir)/
  65.     foreach set $faces(sets) {
  66.         foreach dir $faces(set,$set) {
  67.         if ![file isdirectory $faces(base)$dir] continue
  68.         FaceAddPath $set $dir
  69.         }
  70.     }
  71.     if [info exists faces(set,news)] {
  72.         foreach dir $faces(set,news) {
  73.         if ![file isdirectory $faces(base)$dir] continue
  74.         FaceAddPath news $dir
  75.         }
  76.     }
  77.     }
  78. }
  79. proc FaceAddPath {set dir} {
  80.     global faces
  81.     lappend faces(path,$set) $dir
  82.     set mmap [file exists $faces(base)$dir/machine.tab]
  83.     set pmap [file exists $faces(base)$dir/people.tab]
  84.     set faces(map,$dir) [expr ($mmap<<1) + $pmap]
  85.     if [file isdirectory $faces(base)$dir/MISC] {
  86.     lappend faces(path,$set) $dir/MISC
  87.     set faces(map,$dir/MISC) 0
  88.     }
  89. }
  90.  
  91.  
  92. proc Face_Show { fromwho {xface {}} {ximageurl {}} {newsgrps {}} } {
  93.     global faces faceCache failedURLs exmh
  94.  
  95.     set xfaceAvail 0
  96.     set ximageurlAvail 0
  97.  
  98.     # Don't do any of this if we're on a slow display
  99.     if {!$exmh(slowDispShowFaces)} {
  100.       return 0
  101.     }
  102.  
  103.     Face_Delete
  104.  
  105.     # Honor X-Face even if faces is disabled
  106.     if {$faces(xFaceEnabled) && \
  107.     [string compare "" $xface] && \
  108.     [string compare "" $faces(xfaceProg)]} {
  109.  
  110.     if {$faces(rowEnabled) && $faces(defer)} {
  111.         DeferWork faces(work) [list FaceXFace $xface [FaceAlloc]]
  112.     } elseif {[FaceXFace $xface] && !$faces(rowEnabled)} {
  113.         set xfaceAvail 1
  114.     }
  115.     }
  116.  
  117.     # Honor X-Image-URL even if X-Face was displayed or the faces are
  118.     # disabled
  119.     if {$faces(xImageUrl) && [string compare "" $ximageurl]} {
  120.     if {![info exists failedURLs]
  121.         || ([info exists failedURLs]
  122.         && [lsearch $failedURLs $ximageurl] == -1)} {
  123.          if {$faces(rowEnabled) && $faces(defer)} {
  124.          DeferWork faces(work) \
  125.             [list UrlDisplayFace $ximageurl [FaceAlloc]]
  126.          } elseif {[UrlDisplayFace $ximageurl [FaceAlloc]]
  127.               && !$faces(rowEnabled)} {
  128.         set ximageurlAvail 1
  129.         }
  130.     }
  131.     }
  132.  
  133.     if {$xfaceAvail || $ximageurlAvail} {
  134.     return 1
  135.     }
  136.  
  137.     if {$faces(enabled!) || !$faces(enabled)} {
  138.     return 0
  139.     }
  140.  
  141.     # Check for cached lookup result
  142.     if [info exists faceCache($fromwho,$newsgrps)] {
  143.     if [Face_ShowFace $faceCache($fromwho,$newsgrps)] {
  144.         return 1
  145.     }
  146.     unset faceCache($fromwho,$newsgrps)
  147.     Face_Delete
  148.     }
  149.  
  150.     set msg [Exmh_OldStatus]
  151.     Exmh_Status "Looking up face of $fromwho ..."
  152.  
  153.     set parts [string tolower [split $fromwho @]]
  154.     set user [lindex $parts 0]
  155.     set machine [lindex $parts 1]
  156.     if {[string length $machine] == 0} {
  157.     set machine [string tolower $faces(defaultDomain)]
  158.     } elseif {[string first . $machine] == -1} {
  159.       append machine . $faces(defaultDomain)
  160.     }
  161.  
  162.     set from [split $machine .]
  163.     set pathlist [FacePathlist $from]
  164.  
  165. #Exmh_Debug \n$user ==> $pathlist
  166.  
  167.     set pathlistngfull {}
  168.     if {[string compare "" $newsgrps]} {
  169.     set newsgrplist [string tolower [split $newsgrps ,]]
  170.     foreach ng $newsgrplist {
  171.         set ngparts [split $ng .]
  172.         set pathlistng [FacePathNGlist $ngparts]
  173.         set pathlistngfull [concat $pathlistng $pathlistngfull]
  174.     }
  175.     }
  176.  
  177.     # Loop through Face path
  178. #Tputs lookup: [time {
  179.     set matches {}
  180.     foreach set $faces(sets) {
  181.     eval set tail $faces(name,$set)
  182.         foreach dir $faces(path,$set) {
  183.         set name $tail
  184.         set map {}
  185.         if $faces(map,$dir) {
  186.         if {$faces(map,$dir) & 2} {
  187.             set map [FacePathlist [split \
  188.                 [FaceMap $dir/machine.tab $machine] .]]
  189. #            Exmh_Debug $machine => $map
  190.         }
  191.         if {$faces(map,$dir) & 1} {
  192.             set x [FaceMap $dir/people.tab $machine/$name]
  193. #            Exmh_Debug $machine/$name =>  $x
  194.             if [string compare "" $x] {
  195.             set name $x
  196.             }
  197.         }
  198.         }
  199.         foreach part [concat $map $pathlist] {
  200.             if {([string match unknown* $dir] || [string match misc* $dir])
  201.              && [llength $matches]} {
  202.             break
  203.         }
  204.         set path $dir/$part/$name
  205. #        Exmh_Debug $path
  206.         # skip non-existent directories
  207.         if ![file exists $faces(base)$path] continue
  208.  
  209.         foreach suf $faces(suffix) {
  210.             if [file exists $faces(base)$path/face.$suf] {
  211.             lappend matches $path/face.$suf
  212.             break
  213.             }
  214.         }
  215.         }
  216.     }
  217.     }
  218. #   }]
  219.     eval set tail $faces(name,news)
  220.     foreach dir $faces(path,news) {
  221.     set name $tail
  222.     set map {}
  223.     foreach part [concat $map $pathlistngfull] {
  224. #        if {([string match unknown* $dir] || [string match misc* $dir])
  225. #         && [llength $matches]} {
  226. #        break
  227. #        }
  228.         set path $dir/$part/$name
  229. #        Exmh_Debug $path
  230.         # skip non-existent directories
  231.         if ![file exists $faces(base)$path] continue
  232.  
  233.         foreach suf $faces(suffix) {
  234.         if [file exists $faces(base)$path/face.$suf] {
  235.             lappend matches $path/face.$suf
  236.             break
  237.             }
  238.         }
  239.     }
  240.     }
  241.  
  242. #    Exmh_Debug Faces matches $matches
  243.  
  244.     if !$faces(rowEnabled) {
  245.     foreach face $matches {
  246.         if [Face_ShowFile $face] {
  247.         set faceCache($fromwho,$newsgrps) $face
  248.         Exmh_Status $msg
  249.         return 1
  250.         }
  251.     }
  252.     # braces around cmdsubst NECESSARY!
  253.     } elseif {[Face_ShowFace $matches]} {
  254.     set faceCache($fromwho,$newsgrps) $matches
  255.     Exmh_Status $msg
  256.     return 1
  257.     }
  258.  
  259.     if [llength $matches] {
  260.     Exmh_Status "(no working face found)"
  261.     } else {
  262.     Exmh_Status "(no face found)"
  263.     }
  264.     return 0
  265. }
  266.  
  267. proc FacePathlist { from } {
  268.     set path {}
  269.     set prefix {}
  270.     set pathlist {}
  271.     for {set i [expr [llength $from]-1]} {$i>=0} {incr i -1} {
  272.     append path $prefix [lindex $from $i]
  273.     set prefix /
  274.     set pathlist [concat $path $pathlist]
  275.     }
  276.     lappend pathlist {}
  277.     return $pathlist
  278. }
  279.  
  280. proc FacePathNGlist { ng } {
  281.     set path {}
  282.     set prefix {}
  283.     set pathlist {}
  284.     for {set i 0} {$i <= [expr [llength $ng]-1]} {incr i 1} {
  285.     append path $prefix [lindex $ng $i]
  286.     set prefix /
  287.     set pathlist [concat $path $pathlist]
  288.     }
  289.     lappend pathlist {}
  290.     return $pathlist
  291. }
  292.  
  293. proc Face_Delete {} {
  294.     global faces
  295.  
  296.     if [info exists faces(work)] {
  297.     DeferWorkCancel faces(work)
  298.     }
  299.  
  300.     for {set f $faces(avail)} {$f > 0} {incr f -1} {
  301.     catch {
  302.         set image [$faces(frame).l$f cget -image]
  303.         if [string compare "" $image] {
  304.         $faces(frame).l$f config -image {}
  305.         image delete $image
  306.         }
  307.     }
  308.     $faces(frame).l$f config -bitmap {}
  309.     if {$faces(rowEnabled) && [info exists faces(rowbg)]} {
  310.         $faces(frame).l$f config -bg $faces(rowbg)
  311.     }
  312.     }
  313.     set faces(avail) 0
  314.  
  315.     if !$faces(rowEnabled) {
  316.     raise $faces(default)
  317.     }
  318. }
  319.  
  320. proc FaceAlloc {} {
  321.     global faces
  322.  
  323.     set new 0
  324.     if {!$faces(rowEnabled) && $faces(avail)} {
  325.         catch {
  326.             set image [$faces(frame).l$faces(avail) cget -image]
  327.             if [string compare "" $image] {
  328.                 $faces(frame).l$faces(avail) config -image {}
  329.                 image delete $image
  330.             }
  331.         }
  332.     incr faces(avail) -1    ;# make us alloc same label
  333.     }
  334.     if {$faces(avail) == $faces(alloc)} {
  335.     Widget_Label $faces(frame) l[incr faces(alloc)] {left fill}
  336.         set new 1
  337.     }
  338.     set label $faces(frame).l[incr faces(avail)]
  339.  
  340.     if !$faces(rowEnabled) {
  341.     if $new {        ;# once ever
  342.         pack forget $label
  343.         place $label -in $faces(default)
  344.     }
  345.     } elseif !$new {
  346.     $label config -bg $faces(facebg)
  347.     }
  348.  
  349.     return $label
  350. }
  351. proc Face_BusyParent {} {
  352.     global faces
  353.     return $faces(frame)
  354. }
  355. proc Face_BusyPlace {busy} {
  356.     global faces
  357.     place $busy -in $faces(frame) -anchor c -relx 0.5 -rely 0.5
  358.     raise $busy
  359.     update idletasks
  360. }
  361. proc Face_BusyDestroy {busy} {
  362.     global faces
  363.     catch {
  364.     destroy $busy
  365.     # This hack forces the underlying labels to redisplay immediatly
  366.     $faces(default) config -fg [lindex [$faces(default) config -fg] 4]
  367.     $faces(frame).l1 config -fg [lindex [$faces(frame).l1 config -fg] 4]
  368.     }
  369. }
  370. proc Face_ShowFace facelist {
  371.     foreach face $facelist {
  372.     if ![FaceShowFile $face [FaceAlloc]] {
  373.         return 0
  374.     }
  375.     }
  376.     return 1
  377. }
  378. proc Face_ShowFile facefile {
  379.     set pane [FaceAlloc]
  380.     if ![FaceShowFile $facefile $pane] {
  381.     $pane config -bitmap error
  382.     return 0
  383.     }
  384.     return 1
  385. }
  386. proc FaceShowFile {facefile pane} {
  387.     global faces
  388.  
  389.     if ![string match /* $facefile] {
  390.     set facefile $faces(base)$facefile
  391.     }
  392.     switch -- [file extension $facefile] {
  393.     .ppm - .pgm - .pbm - .gif - .xpm {
  394.         if [catch {
  395. # Tputs image create: [time {
  396.         set image [image create photo -file $facefile -palette $faces(palette)]
  397. # }]
  398.         if $faces(defer) {
  399.             DeferWork faces(work) [list $pane config -image $image] \
  400.                   [list image delete $image]
  401.  
  402.         } else {
  403. # Tputs image display: [time {
  404.             $pane config -image $image
  405. # }]
  406.         }
  407.         } id] {
  408.         Exmh_Debug $id
  409.         return 0
  410.         }
  411.     }
  412.     .xbm {
  413.         if [catch {
  414.         $pane config -bitmap @$facefile
  415.         } id] {
  416.         Exmh_Debug $id
  417.         return 0
  418.         }
  419.     }
  420.     }
  421.     if !$faces(rowEnabled) {
  422.         raise $pane
  423.     }
  424.     return 1
  425. }
  426.  
  427. proc FaceXFace { xface {pane {}}} {
  428.     global faces
  429.     Exmh_Status "$faces(xfaceProg)" red
  430. # Tputs decode x-face: [time {
  431.     if [catch {open "| $faces(xfaceProg) > [Env_Tmp]/FACE.[pid].xbm" w} fid] {
  432.     Exmh_Status $fid error
  433.     return 0
  434.     } else {
  435.     Exmh_Status "$faces(xfaceProg)"
  436.     }
  437.     puts $fid $xface
  438.     if [catch {close $fid} err] {
  439.     Exmh_Status $err error
  440.     return 0
  441.     }
  442. # }]
  443.     if [string match "" $pane] {
  444.     set pane [FaceAlloc]
  445.     }
  446. # Tputs show x-face: [time {
  447.     set ret [FaceShowFile [Env_Tmp]/FACE.[pid].xbm $pane]
  448. # }]
  449.     File_Delete [Env_Tmp]/FACE.[pid].xbm
  450.     Exmh_Status ok
  451.     return $ret
  452. }
  453.  
  454. #
  455. # Hook for button in faces area
  456. #
  457. proc Faces_Button {{cmd ""} {label ""} {pack {left fill}}} {
  458.     global faces
  459.     catch {destroy $faces(button)}
  460.     set faces(button) [Widget_AddBut $faces(frame) b $label $cmd $pack]
  461.     $faces(button) config -padx 0 -pady 0
  462.     pack $faces(button) -after $faces(default)
  463.     return $faces(button)
  464. }
  465. proc Faces_ClearButton {} {
  466.     global faces
  467.     catch {destroy $faces(button)}
  468. }
  469.  
  470.  
  471. # Faces information used to be administered by a pair of ASCII files
  472. # in the faces directory that associate related machines and faces.
  473. # EXMH still supports this mechanism, although it's use is discouraged.
  474. # The machine table machine.tab attaches machines to communities; the line
  475. #    stard=sunaus
  476. # puts the machine stard in community sunaus.  The machine
  477. # table may be used to alias entire communities; the line
  478. #    wseng.sun.com=eng.sun.com
  479. # will cause the wseng.sun.com domain to be mapped to the
  480. # eng.sun.com community.  The people table associates a
  481. # community/alias pair, with a real username.
  482. #    sunaus/rburridge=richb
  483. # causes the alias rburridge to be translated into the real
  484. # username richb for the community sunaus
  485.  
  486. proc FaceMachine {dir machine} {
  487.     global faces
  488.     if $faces(mapsEnabled) {
  489.     set map [FaceMap $dir/machine.tab $machine]
  490.     if [string compare "" $map] {
  491.         return $map
  492.     }
  493.     }
  494.     return $machine
  495. }
  496. proc FacePeople {dir machine people} {
  497.     global faces
  498.     if $faces(mapsEnabled) {
  499.     set map [FaceMap $dir/people.tab $machine/$people]
  500.     switch -- [llength $map] {
  501.     0    {}
  502.     1    {return [list $machine $map]}
  503.     default    {return $map}
  504.     }
  505.     }
  506.     return [list $machine $people]
  507. }
  508. proc FaceMap {file item} {
  509.     global faceMap faces
  510.     if [info exists faceMap($file,$item)] {
  511.     return $faceMap($file,$item)
  512.     }
  513.     if { [info exists faceMap(modtime,$file)] &&
  514.     ([file mtime $faces(base)$file]  <= $faceMap(modtime,$file)) } {
  515.     return {}
  516.     }
  517. #    Exmh_Debug FaceMap $file $item
  518.     if ![catch {open $faces(base)$file} in] {
  519.     set faceMap(modtime,$file) [file mtime $faces(base)$file]
  520.     while {[gets $in input] >= 0} {
  521.         set parts [string tolower [split $input =]]
  522.         set lhs [string trim [lindex $parts 0]]
  523.         set rhs [split [string trim [lindex $parts 1]] /]
  524.         set faceMap($file,$lhs) $rhs
  525.     }
  526.     close $in
  527.     if [info exists faceMap($file,$item)] {
  528.         return $faceMap($file,$item)
  529.     }
  530.     }
  531.     return {}
  532. }
  533.  
  534. proc Face_FlushCache {} {
  535.     global faceMap faceCache
  536.     catch {unset faceMap}
  537.     catch {unset faceCache}
  538. }
  539.  
  540. #
  541. # Defer work to an after handler [this code should be elsewhere]
  542. #
  543.  
  544. proc DeferWork {name work {cancel {}}} {
  545.     upvar #0 $name queue
  546.  
  547.     lappend queue [list $work $cancel]
  548.     if {[llength $queue] == 1} {
  549.     after 50 DeferWorkProc $name
  550.     }
  551. }
  552. proc DeferWorkCancel name {
  553.     upvar #0 $name queue
  554.  
  555.     if [info exists queue] {
  556.     after cancel [list DeferWorkProc $name]
  557.     foreach w $queue {
  558.         catch [lindex $w 1]
  559.     }
  560.     unset queue
  561.     }
  562. }
  563. proc DeferWorkProc name {
  564.     upvar #0 $name queue
  565.  
  566.     set this [lindex $queue 0]
  567.     set queue [lrange $queue 1 end]
  568.     catch [lindex $this 0]
  569.     if [llength $queue] {
  570.     after 20 DeferWorkProc $name
  571.     }
  572. }
  573.